home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / LISP / FOOLS / !Fl / scm / macros < prev    next >
Text File  |  1991-10-16  |  2KB  |  90 lines
  1. ;;; extend-syntax macros
  2.  
  3. (require 'extend)
  4. (provide 'macros)
  5.  
  6. (extend-syntax (do)
  7.   [(do ([var init . step] ...) (test texp ...) dexp ...)
  8.    (andmap symbol? '(var ...))
  9.    (with ([do-loop (gensym)]
  10.       [(do-step ...)
  11.        (map (lambda (x y)
  12.           (if (null? y) x (car y)))
  13.         '(var ...) '(step ...))])
  14.      (letrec ((do-loop
  15.            (lambda (var ...)
  16.          (if test
  17.              (begin texp ...)
  18.              (begin dexp ... (do-loop do-step ...))))))
  19.        (do-loop init ...)))])
  20.       
  21. (extend-syntax (record-case else)
  22.   [(record-case val (else exp ...))
  23.    (begin exp ...)]
  24.   [(record-case val clause ...)
  25.    (pair? 'val)
  26.    (with ([temp (gensym)])
  27.      (let ([temp val])
  28.        (record-case temp clause ...)))]
  29.   [(record-case val (key idspec exp ...) more ...)
  30.    (with ([bindings
  31.        (let parse ([pat 'idspec] [acc '(cdr val)] [recs '()])
  32.          (cond ((symbol? pat)
  33.             (cons (list pat acc) recs))
  34.            ((pair? pat)
  35.             (parse (car pat)
  36.                `(car ,acc)
  37.                (parse (cdr pat)
  38.                   `(cdr ,acc)
  39.                   recs)))
  40.            (else recs)))]
  41.       [same? (if (symbol? 'key) eq? eqv?)])
  42.      (if (same? (car val) 'key)
  43.      (let bindings exp ...)
  44.      (record-case val more ...)))]
  45.   [(record-case val) #f])
  46.  
  47. (extend-syntax (define-structure)
  48.   ;; from "The Scheme Programming Language" by R. Kent Dybvig
  49.   [(define-structure (name id1 ...))
  50.    ; XXX: (begin ...) necessary to avoid macro short-circuiting
  51.    (begin (define-structure (name id1 ...) ()))]
  52.   [(define-structure (name id1 ...) ([id2 val] ...))
  53.    (with ([constructor
  54.        (string->symbol (string-append "make-" 'name))]
  55.       [predicate
  56.        (string->symbol (string-append 'name "?"))]
  57.       [(access ...)
  58.        (map (lambda (x)
  59.           (string->symbol (string-append 'name "-" x)))
  60.         '(id1 ... id2 ...))]
  61.       [(assign ...)
  62.        (map (lambda (x)
  63.           (string->symbol
  64.            (string-append "set-" 'name "-" x "!")))
  65.         '(id1 ... id2 ...))]
  66.       [count (length '(name id1 ... id2 ...))])
  67.      (with ([(index ...)
  68.          (let f ([i 1])
  69.            (if (= i 'count)
  70.            '()
  71.            (cons i (f (+ i 1)))))])
  72.        (begin
  73.      (define constructor
  74.        (lambda (id1 ...)
  75.          (let* ([id2 val] ...)
  76.            (vector 'name id1 ... id2 ...))))
  77.      (define predicate
  78.        (lambda (obj)
  79.          (and (vector? obj)
  80.           (= (vector-length obj) count)
  81.           (eq? (vector-ref obj 0) 'name))))
  82.      (define access
  83.        (lambda (obj)
  84.          (vector-ref obj index)))
  85.      ...
  86.      (define assign
  87.        (lambda (obj newval)
  88.          (vector-set! obj index newval)))
  89.      ...)))])
  90.